home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Almathera Ten Pack 3: CDPD 3
/
Almathera Ten on Ten - Disc 3: CDPD3.iso
/
fish
/
001-100
/
001-025
/
003
/
xlisp
/
xleval.c
< prev
next >
Wrap
C/C++ Source or Header
|
1995-03-17
|
8KB
|
344 lines
/* xleval - xlisp evaluator */
#include "xlisp.h"
/* external variables */
extern NODE *xlstack,*xlenv,*xlnewenv;
extern NODE *s_lambda,*s_macro;
extern NODE *k_optional,*k_rest,*k_aux;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_unbound;
extern NODE *s_stdout;
/* forward declarations */
FORWARD NODE *xlxeval();
FORWARD NODE *evalhook();
FORWARD NODE *evform();
FORWARD NODE *evsym();
FORWARD NODE *evfun();
/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
NODE *expr;
{
return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
}
/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
NODE *expr;
{
/* evaluate nil to itself */
if (expr == NIL)
return (NIL);
/* add trace entry */
xltpush(expr);
/* check type of value */
if (consp(expr))
expr = evform(expr);
else if (symbolp(expr))
expr = evsym(expr);
/* remove trace entry */
xltpop();
/* return the value */
return (expr);
}
/* xlapply - apply a function to a list of arguments */
NODE *xlapply(fun,args)
NODE *fun,*args;
{
NODE *val;
/* check for a null function */
if (fun == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun))
val = (*fun->n_subr)(args);
else if (consp(fun)) {
if (car(fun) != s_lambda)
xlfail("bad function type");
val = evfun(fun,args);
}
else
xlfail("bad function");
/* return the result value */
return (val);
}
/* evform - evaluate a form */
LOCAL NODE *evform(expr)
NODE *expr;
{
NODE *oldstk,fun,args,*val,*type;
/* create a stack frame */
oldstk = xlsave(&fun,&args,NULL);
/* get the function and the argument list */
fun.n_ptr = car(expr);
args.n_ptr = cdr(expr);
/* evaluate the first expression */
if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
xlfail("bad function");
/* evaluate the function */
if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
if (subrp(fun.n_ptr))
args.n_ptr = xlevlist(args.n_ptr);
val = (*fun.n_ptr->n_subr)(args.n_ptr);
}
else if (consp(fun.n_ptr)) {
if ((type = car(fun.n_ptr)) == s_lambda) {
args.n_ptr = xlevlist(args.n_ptr);
val = evfun(fun.n_ptr,args.n_ptr);
}
else if (type == s_macro) {
args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
val = xleval(args.n_ptr);
}
else
xlfail("bad function type");
}
else if (objectp(fun.n_ptr))
val = xlsend(fun.n_ptr,args.n_ptr);
else
xlfail("bad function");
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(expr)
NODE *expr;
{
NODE *oldstk,*oldenv,fun,args,*val;
/* create a new stack frame */
oldstk = xlsave(&fun,&args,NULL);
/* get the hook function */
fun.n_ptr = s_evalhook->n_symvalue;
/* make an argument list */
args.n_ptr = newnode(LIST);
rplaca(args.n_ptr,expr);
/* rebind the hook functions to nil */
oldenv = xlenv;
xlsbind(s_evalhook,NIL);
xlsbind(s_applyhook,NIL);
/* call the hook function */
val = xlapply(fun.n_ptr,args.n_ptr);
/* unbind the symbols */
xlunbind(oldenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* xlevlist - evaluate a list of arguments */
NODE *xlevlist(args)
NODE *args;
{
NODE *oldstk,src,dst,*new,*last,*val;
/* create a stack frame */
oldstk = xlsave(&src,&dst,NULL);
/* initialize */
src.n_ptr = args;
/* evaluate each argument */
for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
/* check this entry */
if (!consp(src.n_ptr))
xlfail("bad argument list");
/* allocate a new list entry */
new = newnode(LIST);
if (val)
rplacd(last,new);
else
val = dst.n_ptr = new;
rplaca(new,xleval(car(src.n_ptr)));
last = new;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new list */
return (val);
}
/* evsym - evaluate a symbol */
LOCAL NODE *evsym(sym)
NODE *sym;
{
NODE *p;
/* check for a reference to an instance variable */
if ((p = xlobsym(sym)) != NIL)
return (car(p));
/* get the value of the variable */
while ((p = sym->n_symvalue) == s_unbound)
xlunbound(sym);
/* return the value */
return (p);
}
/* xlunbound - signal an unbound variable error */
xlunbound(sym)
NODE *sym;
{
xlcerror("try evaluating symbol again","unbound variable",sym);
}
/* evfun - evaluate a function */
LOCAL NODE *evfun(fun,args)
NODE *fun,*args;
{
NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
/* create a stack frame */
oldstk = xlsave(&cptr,NULL);
/* skip the function type */
if ((fun = cdr(fun)) == NIL || !consp(fun))
xlfail("bad function definition");
/* get the formal argument list */
if ((fargs = car(fun)) && !consp(fargs))
xlfail("bad formal argument list");
/* bind the formal parameters */
oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
xlabind(fargs,args);
xlfixbindings();
/* execute the code */
for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
val = xlevarg(&cptr.n_ptr);
/* restore the environment */
xlunbind(oldenv); xlnewenv = oldnewenv;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs)
NODE *fargs,*aargs;
{
NODE *arg;
/* evaluate and bind each required argument */
while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
/* bind the formal variable to the argument value */
xlbind(arg,car(aargs));
/* move the argument list pointers ahead */
fargs = cdr(fargs);
aargs = cdr(aargs);
}
/* check for the '&optional' keyword */
if (consp(fargs) && car(fargs) == k_optional) {
fargs = cdr(fargs);
/* bind the arguments that were supplied */
while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
/* bind the formal variable to the argument value */
xlbind(arg,car(aargs));
/* move the argument list pointers ahead */
fargs = cdr(fargs);
aargs = cdr(aargs);
}
/* bind the rest to nil */
while (consp(fargs) && !iskeyword(arg = car(fargs))) {
/* bind the formal variable to nil */
xlbind(arg,NIL);
/* move the argument list pointer ahead */
fargs = cdr(fargs);
}
}
/* check for the '&rest' keyword */
if (consp(fargs) && car(fargs) == k_rest) {
fargs = cdr(fargs);
if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
xlbind(arg,aargs);
else
xlfail("symbol missing after &rest");
fargs = cdr(fargs);
aargs = NIL;
}
/* check for the '&aux' keyword */
if (consp(fargs) && car(fargs) == k_aux)
while ((fargs = cdr(fargs)) != NIL && consp(fargs))
xlbind(car(fargs),NIL);
/* make sure the correct number of arguments were supplied */
if (fargs != aargs)
xlfail(fargs ? "too few arguments" : "too many arguments");
}
/* iskeyword - check to see if a symbol is a keyword */
LOCAL int iskeyword(sym)
NODE *sym;
{
return (sym == k_optional || sym == k_rest || sym == k_aux);
}
/* xlsave - save nodes on the stack */
NODE *xlsave(n)
NODE *n;
{
NODE **nptr,*oldstk;
/* save the old stack pointer */
oldstk = xlstack;
/* save each node */
for (nptr = &n; *nptr != NULL; nptr++) {
rplaca(*nptr,NIL);
rplacd(*nptr,xlstack);
xlstack = *nptr;
}
/* return the old stack pointer */
return (oldstk);
}